home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1997 September / Macworld (1997-09).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / procs.tcl < prev    next >
Text File  |  1997-03-28  |  34KB  |  1,339 lines
  1.  
  2. #==============================================================================
  3. # Load electric alias, rebind tcl file completion for precedence.
  4. proc loadElectricAlias {} {
  5.     global HOME
  6.     uplevel #0 {
  7.         source "$HOME:Tcl:ElectricAlias:electricAlias.tcl"
  8.     }
  9.     message "ElectricAlias loaded."
  10.     bind '\t' tclFileCompletion "Shel"
  11.     enableMenuItem -m install "Electric Alias" off
  12. }
  13.  
  14. proc debug {} {
  15.     uplevel #0 {
  16.         set debugging 1
  17.     }
  18. }
  19.  
  20.  
  21. proc normalLeftBracket {} {
  22.     insertText "\{"
  23. }
  24. proc normalRightBracket {} {
  25.     insertText "\}"
  26. }
  27. bind '\[' <zs>  normalLeftBracket
  28. bind '\]' <zs>  normalRightBracket
  29.             
  30. # Select the next or current word. If word already selected, will go to next.
  31. proc hiliteWord {} {
  32.     if {[getPos]!=[selEnd]}    forwardChar
  33.     forwardWord
  34.     set start [getPos]
  35.     backwardWord
  36.     select $start [getPos]
  37. }
  38. bind 'h' <z> hiliteWord
  39.  
  40. #================================================================================
  41. # Mode variables
  42. #================================================================================
  43. # For mark stack.
  44. set markName 0
  45. set markStack ""
  46.  
  47. # mapping of windows to current modes.
  48. set winModes("") ""
  49.  
  50. # making vars local to windows
  51. # 'incomingVars' used to hold old var values that have been overwritten in current window
  52.  
  53. #================================================================================
  54. # Handle 'flag' and 'var' menu selections.
  55. #================================================================================
  56. # proc editFlag {menu item} {
  57. #     global $item incomingVars localVars modifiedVars tcl_var_procs
  58. # 
  59. #     if {[regexp {\? (.*)} $item dummy var]} {
  60. #         alphaHelp
  61. #         eval select [search -f 1 -r 1 "^$var"]
  62. #         return
  63. #     }
  64. #     lappend modifiedVars $item
  65. #     set val [expr ([set $item]-1)*-1]
  66. #     markMenuItem $menu $item [expr ($val)?"on":"off"]
  67. #     set $item $val
  68. # 
  69. #     if {[info exists tcl_var_procs($item)]} {
  70. #         $tcl_var_procs($item) $item
  71. #     }
  72. # }
  73.  
  74. proc editVar {menu item} {
  75.     global $item incomingVars localVars modifiedVars
  76.  
  77.     if {[regexp {\? (.*)} $item dummy var]} {
  78.         alphaHelp
  79.         eval select [search -f 1 -r 1 "^$var"]
  80.         return
  81.     }
  82.     lappend modifiedVars $item
  83.     append prmpt "New Value of " $item ": "
  84.     if ![catch {prompt $prmpt [set $item]} res] {
  85.         set $item $res
  86.     }
  87. }
  88.  
  89.  
  90.  
  91.  
  92. #================================================================================
  93.  
  94. # Instantiate a global variable to the path of a file (usually an app). As a
  95. # side-effect, make the instantiation permanent.
  96. proc addAppPath {name var} {
  97.     global $var modifiedVars
  98.     
  99.     if {$name == "CodeWarrior Compiler"} {
  100.         alertnote {Please locate the compiler via menu item "Config:App Paths:CodeWarrior Compiler"}
  101.         error ""
  102.     } elseif {$name == "CodeWarrior Debugger"} {
  103.         alertnote {Please locate the debugger via menu item "Config:App Paths:CodeWarrior Debugger"}
  104.         error ""
  105.     }
  106.         
  107.     set $var [getfile "Find '$name' app:"]
  108.     lappend modifiedVars $var
  109. }
  110.  
  111.  
  112. proc getFileSig {f} {
  113.     getFileInfo $f arr
  114.     return $arr(creator)
  115. }
  116.  
  117. proc getFileType {f} {
  118.     getFileInfo $f arr
  119.     return $arr(type)
  120. }
  121.  
  122.  
  123. # Look for given app sig in active processes. If not there, try to 
  124. # launch with 'path' prompting for 'path' if necessary.
  125. # Return the real name of the app. Don't switch.
  126.  
  127. # Slightly modified version of 'checkRunning' that looks for any of a
  128. # list of running apps.  The name of the app is returned. 
  129. # 
  130. proc checkRunning {prompt sigs path {in_front 1}} {
  131.     global $path
  132.  
  133.     # See if a process w/ any of the acceptable sigs already running.
  134.     # If so, use it, whether it's the one specified by $path or not.
  135.     #
  136.     foreach proc [processes] {
  137.         # if a running app has the correct sig, ...
  138.         if {[lsearch -exact $sigs [lindex $proc 1]] >= 0} {
  139.             # ...then return its name.
  140.             return [lindex $proc 0]
  141.         }
  142.     }
  143.  
  144.     # If the path variable or the file it references don't exist,
  145.     # or if its sig isn't one that we expect, then prompt the user 
  146.     # to locate the app.
  147.     #
  148.     if {![info exists $path] || ![file exists [set $path]] 
  149.              || [lsearch -exact $sigs [getFileSig [set $path]]] < 0} {
  150.         if {[catch {addAppPath $prompt $path}]} return
  151.     }
  152.  
  153.     # Check that the user's choice has an acceptable sig
  154.     if {[lsearch -exact $sigs [getFileSig [set $path]]] < 0} {
  155.         unset $path
  156.         message "Inappropriate file chosen"
  157.         return {} 
  158.     }
  159.     
  160.     # Launch the app
  161.     if {$in_front} {
  162.         if {[catch {launch -f [set $path]}]} {
  163.             error "Problem with launching file (out of memory?)"
  164.         }
  165.     } else {
  166.         if {[catch {launch [set $path]}]} {
  167.             error "Problem with launching file (out of memory?)"
  168.         }
  169.     }        
  170.     
  171.     # Return the name of the chosen application
  172.     return [file tail [set $path]]
  173. }
  174.  
  175.  
  176. #===============================================================================
  177.  
  178. # Switch to 'sig', launching if necesary
  179. proc launchForeAppl {sig} {
  180.     if {[catch {nameFromAppl $sig} name]} {
  181.         alertnote "Can't find app w/ sig '$sig'. Try rebuilding your desktop or changing your helper apps."
  182.         error ""
  183.     }
  184.     if {![file exists $name]} {
  185.         alertnote "Sig '$sig' is mapped to '$name', which doesn't exist. Try changing your helper apps."
  186.         error ""
  187.     }
  188.     if {[catch {switchTo "'$sig'"}]} {
  189.         launch -f $name
  190.     }        
  191.     return $name
  192. }
  193.  
  194. # Ensure that the app is at least running in the background.
  195. proc launchBackAppl {sig} {
  196.     if {[catch {nameFromAppl $sig} name]} {
  197.         alertnote "Can't find app w/ sig '$sig'. Try rebuilding your desktop or changing your helper apps."
  198.         error ""
  199.     }
  200.     if {![file exists $name]} {
  201.         alertnote "Sig '$sig' is mapped to '$name', which doesn't exist. Try changing your helper apps."
  202.         error ""
  203.     }
  204.     launch $name
  205.     return $name
  206. }
  207.  
  208. # Check to see if any of the 'sigs' is running. If so, return its name.
  209. # Otherwise, attempt to launch the file named by 'sig'.
  210. proc launchBackApplSigs    {sigs sig {prompt "Please locate the application:"}} {
  211.     global $sig    modifiedVars
  212.     foreach    p [processes] {
  213.         if { [set ind [lsearch -exact $sigs [lindex $p 1]]] >= 0 } {
  214.             set s [lindex $sigs $ind]
  215.             if { ![info exists $sig] || ($s != [set    $sig]) } {
  216.                 set    $sig $s
  217.                 lappend    modifiedVars $sig
  218.             }
  219.             return [nameFromAppl $s]
  220.         }
  221.     }
  222.     if {![info exists $sig] || ([set $sig] == "")}    {
  223.         set    $sig [getFileSig [getfile $prompt]]
  224.         lappend    modifiedVars $sig
  225.     }
  226.     return [launchBackAppl [set    $sig]]
  227. }
  228.  
  229. proc getApplSig {prompt sig} {
  230.     global $sig modifiedVars
  231.     if {[catch {nameFromAppl [set $sig]}]} {
  232.         set $sig [getFileSig [getfile $prompt]]
  233.         lappend modifiedVars $sig
  234.     }
  235. }
  236.  
  237. #================================================================================
  238. # Excalibur is the only Mac spell-checker that I know of which will handle LaTeX as
  239. # well as ordinary text.
  240.  
  241.  
  242. proc spellcheckWindow {} {
  243.     global resumeRevert
  244.  
  245.     set name [launchForeAppl XCLB]
  246.  
  247.     if {[winDirty]} {
  248.         if {[askyesno "Save '[lindex [winNames] 0]'?"] == "yes"} {
  249.             save
  250.         }
  251.     }
  252.     sendOpenEvent noReply [file tail $name] [car [winNames -f]]
  253.     set resumeRevert 1
  254. }
  255.  
  256. proc spellcheckSelection {} {
  257.     global excaliburPath 
  258.  
  259.     catch {checkRunning Excalibur XCLB excaliburPath} name
  260.  
  261.     if {[getPos] == [selEnd]} {
  262.         beep
  263.         message "No selection"
  264.         return;
  265.     }
  266.     copy
  267.     switchTo $name
  268. }
  269.  
  270. #================================================================================
  271.  
  272.  
  273. proc alphaHelp {} {
  274.     global HOME alphaLite
  275.     if $alphaLite {
  276.         edit -r "$HOME:Help:Quick Start"
  277.     } else {
  278.         edit -r "$HOME:Help:Manual"
  279.     }
  280. }
  281.  
  282.  
  283. proc tclHelp {} {
  284.     global HOME
  285.     edit -r "$HOME:Help:Tcl Commands"
  286. }
  287.  
  288.  
  289. proc dividingLine {} {
  290.     insertText "===============================================================================\r"
  291. }
  292. bind 'l' <C> dividingLine
  293.  
  294. proc texDividingLine {} {
  295.     insertText "%===============================================================================\r"
  296. }
  297. bind 'l' <C> texDividingLine TeX
  298.  
  299. proc cDividingLine {} {
  300.     insertText "//===============================================================================\r"
  301. }
  302. bind 'l' <C> cDividingLine C
  303. bind 'l' <C> cDividingLine C++
  304.  
  305. proc tclDividingLine {} {
  306.     insertText "#===============================================================================\r"
  307. }
  308. bind 'l' <C> tclDividingLine Tcl
  309.  
  310.  
  311. #================================================================================
  312.  
  313. if {![string length [info commands oldCd]]} {
  314.     rename cd oldCd
  315. }
  316.  
  317. proc cd args {
  318.     global HOME
  319.     if {[llength $args]} {
  320.         set path [string trim [eval list $args] "        \{\}"]
  321.         if {![regexp {:} $path]} {
  322.             set path ":$path"
  323.         }
  324.         oldCd $path
  325.     } else {
  326.         oldCd $HOME
  327.     }
  328. }
  329.  
  330.  
  331.  
  332. #############################################################################
  333. #  List the name and value of each element of the array $arrName.
  334. #  (Convenient to use as a shell command.)
  335. #
  336. #  Note: it's slower to insert the lines one-by-one like this, but 
  337. #  assembling everything in $lines before inserting can seriously crash Alpha
  338. #  if the result is too big.  (Trying to list the contents of $auto_index()
  339. #  will do it.)  This method seems to be more robust.
  340. #
  341. proc listArray {arrName} {
  342.     global $arrName
  343.     set lines {}
  344.     if {![catch {info vars $arrName}]} {
  345.         foreach nm [lsort -ignore [array names $arrName]] {
  346.             append lines [format "\r%-20s \"%s\"" $nm [set ${arrName}($nm)]]
  347.         }
  348.         insertText $lines
  349.     } else {
  350.         alertnote "\"$arrName\" doesn't exist in this context"
  351.     }
  352. }
  353.  
  354.  
  355.  
  356. #================================================================================
  357.     
  358. proc selectParagraph {} {
  359.     set pos [getPos]
  360.     set start [paraStart $pos] 
  361.     set finish [paraFinish $pos]
  362.     goto $start
  363.     select $start $finish
  364. }
  365.  
  366. # wrapText ==  getText ; breakIntoLines ; replaceText
  367. # Remove text from window, transform (join, del-ws), insert back into window.
  368. proc fillTextByPar {from to} {
  369.     set text [getText $from $to]
  370.     regsub -all "\r(\[ \t\]*\r)+" $text "\r\r\r" text
  371.     regsub -all "(\[^\r\])\r" $text "\\1 " text
  372.     regsub -all "\[ \t\]+" $text " " text
  373.     return [breakIntoLines $text]
  374. }
  375.  
  376. proc fillRegionByPar {{start -1} {finish -1}} {
  377. #    # if {[getPos] == [selEnd]} { return}
  378.     if {($start < 0) || ($finish < 0)} {
  379.         set start [lineStart [getPos]]
  380.         set finish [selEnd] }
  381.     if {$start >= $finish} return
  382.     goto $start
  383.     set text [fillTextByPar $start $finish]
  384.     replaceText $start $finish $text "\r"
  385. }
  386.     
  387. #
  388. # join Lines in region -- if no optional args, use selection
  389. #
  390. proc joinRegion {{from -1} {to -1}} {
  391.     if {($from < 0) || ($to < 0)} {    set from [getPos] ; set to [selEnd] }
  392.     if {$from >= $to} return
  393.     set text [getText $from $to]
  394.     regsub -all "\r(\[ \t\]*\r)+" $text "\r\r\r" text
  395.     regsub -all "(\[^\r\])\r" $text "\\1 " text
  396.     replaceText $from $to $text "\r"
  397. }
  398. # WARNING:    regsub ^$ refers to string endpts (not lines)
  399. # FUTURE:    filterLines like perl:
  400. #    replaceText[apply_to_all(cmd,split [getText [getPos] [selEnd]] "\r")]
  401. # OR:    replaceInRegion: dup_\r, $=>\r ??
  402. #
  403.  
  404.  
  405. #
  406. # Remove text from window, transform (delete dup ws), insert back into window.
  407. #
  408. # inputs: message, alertnote, askyesno, listpick, prompt KILLS SELECTION.
  409. # search: bnds = search -forward -regExpr -ignoreCase -matchWords -noabort 
  410. #        -l limit pat pos
  411. # 
  412. proc regsubInRegion {from to srch repl} {
  413.     if {![string length $srch]} return
  414.     if {$from >= $to} return
  415.     set text [getText $from $to]
  416.     regsub -all "$srch" $text "$repl" text
  417.     replaceText $from $to $text
  418. }
  419. #    while {($pos < $to) &&
  420. #          ![catch {search -s -f 1 -r 1 -i 1 -m 0 "$srch" $pos} mtch]} {
  421. #        set mbeg [lindex $mtch 0]
  422. #        set pos [lindex $mtch 1]
  423. #        replaceText $mbeg $pos $repl }
  424.  
  425. #proc backSlashSub {arg} { eval [concat return "\"$arg\""] }
  426.  
  427. proc backSlashSub {arg} {
  428.     regsub -all {\\} $arg {\\\\} arg
  429.     regsub -all {\[} $arg {\\[} arg
  430.     regsub -all {\]} $arg {\\]} arg
  431.     eval [concat return "\"$arg\""]
  432. }
  433.  
  434. proc replaceInRegion {} {
  435.     if [catch {prompt "Search RegExpr:" ""} srch] return
  436.     if [catch {prompt "Replace String:" ""} repl] return
  437.     if {![string length $srch]} return
  438.     regsubInRegion [getPos] [selEnd] \
  439.         [backSlashSub "$srch"] [backSlashSub "$repl"]
  440. }
  441.  
  442. #
  443. # Apply command to each line (or paragraph) in selection ;
  444. #    if no cmd arg then prompts for it
  445. #
  446. proc filterLines {{cmd 0} {parunit 0}} {
  447.     if {$cmd == 0} {
  448.       if {[catch { prompt "Line-filter command: " "" } cmd]} { return } }
  449.     if {![string length $cmd]} return
  450.     set unitStart lineStart
  451.     set unitEnd nextLineStart
  452.     if {$parunit} {
  453.         set unitStart paraStart
  454.         set unitEnd paraFinish }
  455.     set pos [$unitStart [getPos]]
  456.     set finish [selEnd]
  457.     if {$pos >= $finish} return
  458.     goto $pos
  459.     createTMark "filterLend" $finish
  460.     set next [$unitEnd $pos]
  461.     while {(($next > $pos) && ($pos < $finish))} {
  462.         goto [expr $next-1]
  463.         createTMark "filterLnext" $next
  464.         setMark
  465.         goto $pos
  466.         markHilite
  467.         if {[catch [list uplevel #0 "$cmd"] retval]} {
  468.             select $pos $finish
  469.             alertnote $retval
  470.             return
  471.         }
  472.         if {$next==$finish} break
  473.         set ind [lsearch -regexp [lindex [getTMarks] 0] "filterLend.*"]
  474.         set finish [lindex [lindex [lindex [getTMarks] 0] $ind] 2]
  475.         gotoTMark "filterLnext"
  476.         set pos [$unitStart [getPos]]
  477.         set next [$unitEnd $pos]
  478.     }
  479.     removeTMark "filterLend"
  480.     removeTMark "filterLnext"
  481. }
  482.  
  483.  
  484. proc filterParagraphs {{cmd 0}} { filterLines $cmd 1 }
  485.  
  486. # WARNING: deselecting sets the mark to selEnd
  487. proc sortParagraphs {{from -1} {to -1}} {
  488.     if {($from < 0) || ($to < 0)} {    set from [getPos] ; set to [selEnd] }
  489.     if {$from >= $to} return
  490.     joinRegion {$from $to}
  491.     select [getPos] [nextLineStart [getMark]]
  492.     sortLines
  493.     select [getPos] [getPos]
  494.     regsubInRegion [getPos] [getMark] "\r" "\r\r" 
  495.     wrapRegion
  496. }
  497.  
  498. #
  499. # Sample
  500. #
  501. proc filterRegion {{from -1} {to -1} {cmd 0} {newwin 0}} {
  502.     if {$cmd == 0} {
  503.       if {[catch { prompt "Eval command: " "" } cmd]} { return }
  504.     }
  505.     if {![string length $cmd]} return
  506.     if {($from < 0) || ($to < 0)} {    set from [getPos] ; set to [selEnd] }
  507.     if {$from >= $to} return
  508.     set pos [getPos]
  509.     set text [getText $from $to]
  510.     set text [$cmd $text]
  511.     replaceText $from $to $text "\r"
  512.     goto $pos
  513. }
  514.  
  515.  
  516. #
  517. set lastEvaled ""
  518. proc evaluate {} {
  519.     global lastEvaled
  520.     if {[string length $lastEvaled]} {
  521.         set p "M-x ($lastEvaled): "
  522.     } else {
  523.         set p "M-x: "
  524.     }
  525.     if {[catch {statusPrompt $p} text]} {return}
  526.     if {![string length $text]} {set text $lastEvaled}
  527.     $text
  528.     set lastEvaled $text
  529. }
  530.  
  531.  
  532. # First, define macros to bypass the electric braces.
  533. proc ordLeftBrace {} {
  534.     insertText "        \{"
  535. }
  536. bind {'['} <cs> ordLeftBrace
  537.  
  538. proc ordRightBrace {} {
  539.     insertText "\}"
  540.     blink [matchIt "\}" [expr [getPos]-1]]
  541. }
  542. bind {']'} <cs> ordRightBrace
  543.     
  544. proc quoteWord {} {
  545.     backwardWord
  546.     insertText "'"
  547.     forwardWord
  548.     insertText "'"
  549. }
  550. bind ''' <z> quoteWord
  551.  
  552. #================================================================================
  553.  
  554. proc tomac {fname} {
  555.     set fd [open $fname "r"]
  556.     set text [read $fd]
  557.     close $fd
  558.     set fd [open $fname "w"]
  559.     regsub "\n" $text "\r" text
  560.     puts -nonewline $fd $text
  561.     close $fd
  562. }
  563.  
  564. proc tounix {fname} {
  565.     set fd [open $fname "r"]
  566.     set text [read $fd]
  567.     close $fd
  568.     set fd [open $fname "w"]
  569.     regsub "\r" $text "\n" text
  570.     puts -nonewline $fd $text
  571.     close $fd
  572. }
  573.  
  574.  
  575. proc cat args {
  576.     set files ""
  577.     foreach a $args {
  578.         foreach f [glob $a] {
  579.             lappend files $f
  580.         }
  581.     }
  582.     foreach f $files {
  583.         append text "==============<$f>==============\r"
  584.         set fd [open $f "r"]
  585.         append text "[read $fd]\r\r"
  586.         close $fd
  587.     }
  588.     return $text
  589. }
  590.  
  591. proc catto args {
  592.     set len [llength $args]
  593.     set to [lindex $args [expr $len -1]]
  594.     set args [lrange $args 0 [expr $len -2]]
  595.  
  596.     set files ""
  597.     foreach a $args {
  598.         foreach f [glob $a] {
  599.             lappend files $f
  600.         }
  601.     }
  602.     foreach f $files {
  603.         append text "==============<$f>==============\r"
  604.         set fd [open $f "r"]
  605.         append text "[read $fd]\r\r"
  606.         close $fd
  607.     }
  608.  
  609.     set dfile $to
  610.     if {[file exists $dfile]} {
  611.         set fid [open $dfile "a"]
  612.     } else {
  613.         set fid [open $dfile "w"]
  614.     }
  615.     puts $fid $text
  616.     close $fid
  617. }
  618.  
  619.  
  620. ##############################################################################
  621. #  To be used in the windows created by "matchingLines" or by batch searches.
  622. #
  623. #  With the cursor positioned in a line corrsponding to a match, 
  624. #  go back and select the line in the original file that 
  625. #  generated this match.  (Like emacs 'Occur' functionality)
  626. #
  627. proc gotoMatch {} {
  628.     if {[string match "*MAILBOX*" [lindex [winNames] 0]]} {
  629.         mailGotoMatch
  630.         return
  631.     }
  632.     global tileHeight tileWidth tileTop tileLeft tileHeight errorHeight errorDisp tileMargin
  633.     set errorDisp [expr (2 * ($tileHeight - $tileMargin)) / 3]
  634.     set text [getText [lineStart [getPos]] [expr [nextLineStart [getPos]] - 1]]
  635.     set ind1 [string first "∞" $text]
  636.     set ind2 [string last "∞" $text]
  637.     if {$ind1 == $ind2} {
  638.         set fname [string trim [string range $text $ind1 end] {∞}]
  639.         set msg ""
  640.     } else {
  641.         set fname [string trim [string range $text $ind1 $ind2] {∞}]
  642.         set msg [string trim [string range $text $ind2 end] {∞}]
  643.     }
  644.     
  645.     set top $tileTop
  646.     set geo [getGeometry]
  647.     if {([lindex $geo 0] != $tileLeft) || ([lindex $geo 1] != $top) || ([lindex $geo 3] != $errorHeight) } {
  648.         moveWin $tileLeft $top
  649.         sizeWin $tileWidth $errorHeight
  650.     }
  651.     set mar $tileMargin
  652.     incr top [expr $errorHeight + $mar]
  653.     if {[expr {[lsearch [winNames -f] "*$fname"] >= 0}]} {
  654.         if {[string match ":*" $fname]} {
  655.             set fname [file tail $fname]
  656.         }
  657.         bringToFront $fname
  658.         set geo [getGeometry]
  659.         if {([lindex $geo 0] != $tileLeft) || ([lindex $geo 1] != $top) || ([lindex $geo 2] != $tileWidth) || ([lindex $geo 3] != $errorDisp) } {
  660.             sizeWin $tileWidth $errorDisp
  661.             moveWin $tileLeft $top
  662.         }
  663.     } elseif {[file exists $fname]} {
  664.         edit -g $tileLeft $top $tileWidth $errorDisp $fname
  665.     } else {
  666.         if {![string match "*Link*" [getText 0 [nextLineStart 0]]]} {
  667.             alertnote "File \" $fname \" not found." 
  668.         }
  669.         return
  670.     }
  671.     if {[regexp {Line ([0-9]+):} $text dummy line]} {
  672.         set pos [rowColToPos $line 0]
  673.         select $pos [nextLineStart $pos]
  674.     }
  675.     message $msg
  676. }
  677. bind 'c' <Cz>        gotoMatch
  678.  
  679.  
  680. #================================================================================
  681.  
  682. proc prevIntro {} {
  683.     set res [search -s -f 0 -r 0 {== } [getPos]]
  684.     display [lineStart [expr [lineStart [lindex $res 0]] - 1]]
  685. }
  686.  
  687. proc nextIntro {} {
  688.     set res [search -s -f 1 -r 0 {== } [getPos]]
  689.     set res [lindex $res 1]
  690.     set res [search -s -f 1 -r 0 {== } $res]
  691.     display [lineStart [expr [lineStart [lindex $res 0]] - 1]]
  692. }
  693.  
  694. #================================================================================
  695.  
  696. proc searchStart {} {
  697.     global search_start
  698.     select [getPos]
  699.     setMark
  700.     if {[catch {goto $search_start}]} {message "No previous search"}
  701. }
  702.  
  703. #================================================================================
  704.  
  705.  
  706. proc listBindings {} {
  707.     new -n {* Key Bindings *}
  708.     insertText [bindingList]
  709.  
  710.     goto 0
  711.     setWinInfo dirty 0
  712.     setWinInfo read-only 1
  713. }
  714.  
  715.  
  716. proc listFunctions {} {
  717.     global winModes
  718.     new -n {* Functions *}
  719.     insertText "===\r\tCommand-double-click on a function to see its definition\r===\r\r" [join [lsort -ignore [info commands]] "\r"] "\r"
  720.     goto 0
  721.     setWinInfo dirty 0
  722.     changeMode [set winModes([lindex [winNames] 0]) Tcl]
  723. }
  724.  
  725.  
  726. #================================================================================
  727.  
  728. proc printArray {arr} {
  729.     global $arr
  730.         foreach n [array names $arr] {
  731.         append text "$n '[set ${arr}($n)]'\r"
  732.     }
  733.     return [string trim $text "\r"]
  734. }
  735.  
  736. #================================================================================
  737.  
  738. #================================================================================
  739.  
  740. proc sPrompt {msg def} {
  741.     global useStatusBar
  742.     if {!$useStatusBar} {return [prompt $msg $def]}
  743.     if {[catch {statusPrompt "$msg ($def): "} ans]} {
  744.         error "cancel"
  745.     }
  746.     if {![string length $ans]} {return $def}
  747.     return $ans
  748. }
  749.  
  750.  
  751. proc choicesProc {curr c} {
  752.     global choiceList
  753.     if {$c != "\t"} {return $c}
  754.     
  755.     set matches {}
  756.     foreach w $choiceList {
  757.         if {[string match "$curr*" $w]} {
  758.             lappend matches $w
  759.         }
  760.     }
  761.     if {![llength $matches]} {
  762.         beep
  763.     } else {
  764.         return [string range [largestPrefix $matches] [string length $curr] end]
  765.     }
  766.     return ""
  767. }
  768.  
  769.  
  770. proc sPromptChoices {msg def choiceListIn} {
  771.     global useStatusBar choiceList
  772.     set choiceList $choiceListIn
  773.     if {[catch {statusPrompt -f "$msg ($def): " choicesProc} ans]} {
  774.         error "cancel"
  775.     }
  776.     if {![string length $ans]} {return $def}
  777.     return $ans
  778. }
  779.  
  780. #================================================================================
  781. proc quoteChar {} {
  782.     message "Literal keystroke to be inserted:"
  783.     insertText [getChar]
  784. }
  785. #===============================================================================
  786.  
  787. proc saveACopyAs {} {
  788.     if {[file exists [set nm [car [winNames -f]]]]} {
  789.         set nm2 [putfile "Save a copy as:" [file tail $nm]]
  790.         cp $nm $nm2
  791.     }
  792. }
  793. #===============================================================================
  794. proc removeDups {l} {
  795.     set lout ""
  796.     foreach f $l {
  797.         if {![info exists silly($f)]} {
  798.             set silly($f) 1
  799.             lappend lout $f
  800.         }
  801.     }
  802.     return $lout
  803. }
  804.             
  805.  
  806. #===============================================================================
  807.  
  808. proc printLeftHeader {pg} {
  809.     global printHeader printHeaderTime printHeaderFullPath
  810.     
  811.     if {!$printHeader} return ""
  812.     
  813.     if {$printHeaderFullPath} {
  814.         set text [car [winNames -f]]
  815.     } else {
  816.         set text [lindex [winNames] 0]
  817.     }
  818.     
  819.     if {$printHeaderTime} {
  820.         append text "      [join [mtime [now] short]]"
  821.     }
  822. }
  823.  
  824. proc printRightHeader {pg} {
  825.     return "Page $pg"
  826. }
  827.  
  828. #===============================================================================
  829.  
  830. proc toggleNumLock {} {
  831.     global numLock modifiedVars
  832.     
  833.     set numLock [expr -1 * ($numLock - 1)]
  834.     lappend modifiedVars numLock
  835. }
  836.  
  837. #===============================================================================
  838.  
  839. proc register {} {
  840.     global HOME
  841. #    edit -r "$HOME:Help:Registering"
  842.     launch -f "$HOME:Register"
  843. }
  844.  
  845. #===============================================================================
  846. # Useful for -command flag of 'lsort'.
  847. proc sortByTail {one two} {
  848.     string compare [file tail $one] [file tail $two]
  849. }
  850.  
  851.  
  852. #===============================================================================
  853.  
  854. proc cmdDoubleClick {{from -1} {to -1} {shift 0} {option 0} {control 0}} {
  855.     global mode alphaLite
  856.     
  857.     if {!$alphaLite && [string length [set whe [expandURL]]]} {
  858.         sendUrl [getSelect]
  859.     } else {
  860.         if {$from < 0} {
  861.             set from [getPos]
  862.             set to [selEnd]
  863.             if {$from == $to} {
  864.                 hiliteWord
  865.                 set from [getPos]
  866.                 set to [selEnd]
  867.             }
  868.         }
  869.         
  870.         if {[string length [info commands ${mode}DblClick]]} {
  871.             if {[llength [info args ${mode}DblClick]] == 2} {
  872.                 ${mode}DblClick $from $to
  873.             } else {
  874.                 ${mode}DblClick $from $to $shift $option $control
  875.             }
  876.         } else {
  877.             message "No docs"
  878.         }
  879.     }    
  880. }
  881.  
  882. #===============================================================================
  883.  
  884.  
  885. proc editMark {fname mname args} {
  886.     if {[set pos [lsearch [winNames -f] "*$fname*"]] >= 0}  {
  887.         bringToFront [lindex [winNames -f] $pos]
  888.     } else {
  889.         if {[lsearch $args {-r}] >= 0} {
  890.             edit -r "$fname"
  891.         } else {
  892.             edit "$fname"
  893.         }
  894.     }
  895.     if {[lsearch [getNamedMarks -n] "* ${mname}*"] < 0} {
  896.         global    mode
  897.         catch {${mode}MarkFile}
  898.     } 
  899.     gotoMark $mname
  900. }
  901.  
  902.  
  903. proc winDirty {} {
  904.     getWinInfo arr
  905.     return $arr(dirty)
  906. }
  907.  
  908.  
  909. #===============================================================================
  910.  
  911. proc lreverse {l} {
  912.     if {[llength $l] > 1} {
  913.         set first [lindex $l 0]
  914.         set l [lreverse [lrange $l 1 end]]
  915.         lappend l $first
  916.     }
  917.     return $l
  918. }
  919.  
  920.     
  921. #===============================================================================
  922.  
  923.  
  924. set {patternLibrary(Pascal to C Comments)}      { {\{([^\}]*)\}}    {/* \1 */}     }
  925. set {patternLibrary(C++ to C Comments)}            { {//(.*)}            {/* \1 */}     }
  926. set {patternLibrary(Space Runs to Tabs)}        { { +}                {\t}         }
  927.  
  928.  
  929.  
  930. proc getPatternLibrary {} {
  931.     global patternLibrary
  932.     
  933.     foreach nm [array names patternLibrary] {
  934.         lappend nms [concat [list $nm] $patternLibrary($nm)]
  935.     }
  936.     return $nms
  937. }
  938.  
  939. proc rememberPatternHook {search replace} {
  940.     global patternLibrary
  941.     if {[catch {set name [prompt "New pattern's name?" ""]}]} {
  942.         return ""
  943.     }
  944.     addArrDef patternLibrary $name [list $search $replace]
  945.     set patternLibrary($name) [list $search $replace]
  946.     return $name
  947. }
  948.  
  949. proc deletePatternHook {} {
  950.     global patternLibrary
  951.     
  952.     
  953.     set temp [list prompt "Delete which pattern?" [lindex [array names patternLibrary] 0] "Pats:"]
  954.     set name [eval [concat $temp [array names patternLibrary]]]
  955.     removeArrDef patternLibrary $name
  956.     unset patternLibrary($name)
  957. }
  958.  
  959. #===============================================================================
  960. # Support for Peter Gontier's 'ClickWarrior' (Doesn't work for 68k).
  961. #===============================================================================
  962.  
  963. eventHandler ALFA CWOF clickHandler
  964.  
  965. proc clickHandler {msg} {
  966.     global HOME ALPHA CODEWarrior CWCLASS
  967.     switchTo $ALPHA
  968.     checkCw
  969.     if {[regexp {“(.*)”.*«.*».*«(.*)».*«(.*)»} $msg dummy fname find sind]} {
  970.         set res [AEBuild -t 500000 -r $CODEWarrior $CWCLASS GFil "----" "long(«0000$find»)" Segm "long($sind)"]
  971.         if {[regexp {FTxt} $res]} {
  972.             regexp {«(.*)»} $res dummy spec
  973.             set f [specToPathName $spec]
  974.             edit $f
  975.         }
  976.     }
  977. }
  978.  
  979. #===============================================================================
  980. proc quickFind {} {isearch}
  981. proc reverseQuickFind {} {rsearch}
  982.  
  983. proc pushPosition {} {pushMark}
  984. proc popPosition {} {popMark}
  985. #===============================================================================
  986. proc literalChar {} {
  987.     return [expr {[lookAt [expr [getPos] - 1]] == "\\"}]
  988. }
  989. proc isSelection {} {
  990.     return [string length [getSelect]]
  991. }
  992.  
  993. proc findPatJustBefore { findpat pat {pos ""} {matchw ""} } {
  994.     if { $pos == "" } {set pos [getPos] }
  995.     if { $matchw != "" } { upvar  $matchw word }
  996.     if { ![catch {search -s -f 0 -r 1 "$findpat" $pos} res] } {
  997.         if { [regexp "$pat" [getText [lindex $res 0] $pos] dum word] } {
  998.             return [lindex $res 0]
  999.         }
  1000.     }
  1001.     return
  1002. }
  1003.  
  1004. #===============================================================================
  1005. proc mkdir {dir} {
  1006.     oldMkdir [list $dir]
  1007. }
  1008.  
  1009. proc rmdir {dir} {
  1010.     oldRmdir [list $dir]
  1011. }
  1012.  
  1013. #===============================================================================
  1014. proc textToAlpha {{dir ""}} {
  1015.     set num 0
  1016.     if {![string length $dir]} {
  1017.         set dir [get_directory -p "Creators to 'ALFA':"]
  1018.     }
  1019.  
  1020.     if {![catch {glob "$dir:*"} files]} {
  1021.         foreach f $files {
  1022.             if {[file isfile $f] && ([getFileType $f] == "TEXT") && ([getFileSig $f] != "ALFA")} {
  1023.                 message $f
  1024.                 setFileInfo $f creator ALFA
  1025.                 incr num
  1026.             } elseif {[file isdir $f]} {
  1027.                 incr num [textToAlpha $f]
  1028.             }
  1029.         }
  1030.     }
  1031.     message "Converted $num files"
  1032.     return $num
  1033. }
  1034.  
  1035.  
  1036. #===============================================================================
  1037.  
  1038. proc briefThing {} {
  1039.     global lastBrief
  1040.     getWinInfo arr
  1041.     set curr $arr(currline)
  1042.     set where [posToRowCol [getPos]]
  1043.     set row [car $where]
  1044.     set col [cadr $where]
  1045.     
  1046.     if {$col} {
  1047.         set lastBrief [getPos]
  1048.         goto [lineStart [getPos]]
  1049.     } elseif {$curr != $row} {
  1050.         goto [rowColToPos $curr 0]
  1051.     } elseif {[getPos]} {
  1052.         goto 0
  1053.     } else {
  1054.         goto $lastBrief
  1055.     }
  1056. }
  1057.  
  1058. ########################################
  1059. #                                       #
  1060. #    A few random lisp'ish functions.   #
  1061. #                                       #
  1062. ########################################
  1063.  
  1064. proc car {l} {lindex $l 0}
  1065. proc cadr {l} {lindex $l 1}
  1066. proc caddr {l} {lindex $l 2}
  1067. proc cadddr {l} {lindex $l 3}
  1068. proc caddddr {l} {lindex $l 4}
  1069. proc cdr {l} {lrange $l 1 end}
  1070. proc cddr {l} {lrange $l 2 end}
  1071. proc cons {e l} {concat [list $e] $l}
  1072. proc mapcar args {return [eval map $args]}
  1073.  
  1074. proc map {func l} {
  1075.     set out {}
  1076.     foreach el $l {
  1077.         lappend out [eval $func [list $el]]
  1078.     }
  1079.     return $out
  1080. }
  1081.  
  1082.  
  1083. #===============================================================================
  1084.  
  1085. proc deconstruct {} {
  1086.     global HOME 
  1087.     
  1088.     set files {}
  1089.     if {![catch {glob "$HOME:Tcl:Modes:*Mode.tcl"} modes]} {
  1090.         set files $modes
  1091.     }
  1092.     if {![catch {glob "$HOME:Tcl:Menus:*Menu.tcl"} menus]} {
  1093.         set files [concat $files $menus]
  1094.     }
  1095.     
  1096.     foreach f $files {
  1097.         regexp {.*:(.*)M.*.tcl} $f dummy it
  1098.         set theFiles($it) $f
  1099.         lappend tails $it
  1100.     }
  1101.  
  1102.     set res [listpick -p "Permanently remove which modes and menus?" -l [lsort -ignore $tails]]
  1103.     
  1104.     if {[llength $res] && ([askyesno "Are you absolutely sure?"] == "yes")} {
  1105.         foreach tag $res {
  1106.             set name $theFiles($tag)
  1107.             regexp {(.*)M.*.tcl} $name dummy prefix
  1108.             foreach f [glob "${prefix}*.tcl"] {
  1109.                 lappend rfiles $f
  1110.             }
  1111.  
  1112.             set tag [file tail $tag]
  1113.             if {$tag == "perl"} {
  1114.                 catch {rm $HOME:Help:*Perl*}
  1115.             } elseif {$tag == "latex"} {
  1116.                 catch {rm $HOME:Help:LaTeX*}
  1117.             } elseif {$tag == "bibtex"} {
  1118.                 catch {rm $HOME:Help:Bib*}
  1119.             } elseif {$tag == "html"} {
  1120.                 catch {rm $HOME:Help:HTML*}
  1121.             }
  1122.         }
  1123.  
  1124.         foreach f $rfiles {
  1125.             catch {rm $f}
  1126.         }
  1127.  
  1128.         foreach dir [list "$HOME:Tools" "$HOME:Tcl:ElectricAlias" "$HOME:Tcl:UserCode" "$HOME:Help"] {
  1129.             if {[file exists $dir] && ([askyesno "Remove '$dir'?"] == "yes")} {
  1130.                 if {[catch {recursiveRm $dir}]} {
  1131.                     alertnote "Problem removing '$dir'."
  1132.                 }
  1133.             }
  1134.         }
  1135.         
  1136.         rebuildTclIndices
  1137.  
  1138.         alertnote "You must now restart Alpha..."
  1139.         quit
  1140.     }
  1141. }
  1142.  
  1143. proc recursiveRm dir {
  1144.     if {![catch {glob $dir:*} files]} {
  1145.         foreach f $files {
  1146.             if {[file isdir $f]} {
  1147.                 recursiveRm $f
  1148.             } else {
  1149.                 rm $f
  1150.             }
  1151.         }
  1152.     }
  1153.     rmdir $dir
  1154. }
  1155.  
  1156. ###########################################################################
  1157. #  better-cp-mv.tcl  -- modification of your routines, by Mark Nagata
  1158. #  for Alpha 5.72,  1/04/94
  1159. ###########################################################################
  1160. proc cp args {
  1161.     if {[set len [llength $args]] < 2} {
  1162.         error "usage: cp <file1> <file2>\r       cp <file1> .... <dir>"
  1163.     }
  1164.     set len [expr $len-1]
  1165.     set dir [lindex $args $len]
  1166.     if {![regexp {:} $dir] && $dir != ""} {
  1167.         set dir ":$dir"
  1168.     }
  1169.     if {[regexp {:$} $dir]} {
  1170.         set dir [string trimright $dir {:}]
  1171.     }
  1172.     set args [lreplace $args $len $len]
  1173.     set files {}
  1174.     foreach arg $args {
  1175.         append files " " [glob $arg]
  1176.     }
  1177.     set report ""
  1178.     if {[llength $files] == 1} {
  1179.         set f [lindex $files 0]
  1180.         if {[file exists $dir]} {
  1181.             set targ $dir:[file tail $f]
  1182.             append report $f\ ->\ $targ \r 
  1183.             copyFile $f $targ
  1184.         } else {
  1185.             append report $f\ ->\ $dir \r
  1186.             copyFile $f $dir
  1187.         }
  1188.     } else {
  1189.         foreach f $files {
  1190.             message [file tail $f]
  1191.             set targ $dir:[file tail $f]
  1192.             if {[catch {copyFile $f $targ} that]} {
  1193.                 append report "Error copying '$f': $that\r"
  1194.             } else {
  1195.                 append report $f\ ->\ $targ \r
  1196.             }
  1197.         }
  1198.     }
  1199.     echo [string trimright $report]
  1200. }
  1201.  
  1202. proc mv args {
  1203.     if {[set len [llength $args]] < 2} {
  1204.         error "usage: mv <file1> <file2>\r       mv <file1> .... <dir>"
  1205.     }
  1206.     set len [expr $len-1]
  1207.     if {![regexp {.*[^:]} [lindex $args $len] dir]} {
  1208.         set dir [string range [lindex $args $len] 1 end]
  1209.     }
  1210.     if {![regexp {:} $dir] && $dir != ""} {
  1211.         set dir [concat :$dir]}
  1212.     set args [lreplace $args $len $len]
  1213.     set files {}
  1214.     foreach arg $args {
  1215.         append files " " [glob $arg]
  1216.     }
  1217.     set report ""
  1218.     if {[llength $files] == 1} {
  1219.         set f [lindex $files 0]
  1220.         if {[file exists $dir]} {
  1221.             set targ $dir:[file tail $f]
  1222.             append report $f\ >->\ $targ \r
  1223.             moveFile $f $targ
  1224.         } else {
  1225.             append report $f\ >->\ $dir \r
  1226.             moveFile $f $dir
  1227.         }
  1228.     } else {
  1229.         foreach f $files {
  1230.             message [file tail $f]
  1231.             set targ $dir:[file tail $f]
  1232.             if {[catch {moveFile $f $targ} that]} {
  1233.                 append report "Error moving '$f': $that\r"
  1234.             } else {
  1235.                 append report $f\ >->\ $targ \r
  1236.             }
  1237.         }
  1238.     }
  1239.     echo [string trimright $report]
  1240. }
  1241.  
  1242.  
  1243. proc rm args {
  1244.     set files {}
  1245.     foreach arg $args {
  1246.         append files " " [glob $arg]
  1247.     }
  1248.     foreach f $files {
  1249.         message [file tail $f]
  1250.         removeFile $f
  1251.     }
  1252. }
  1253.  
  1254.  
  1255. #===============================================================================
  1256. proc deleteTill {} {
  1257.     set pos [getPos]
  1258.     set pat [statusPrompt "Delete text until?: (Date): "]
  1259.     if {$pat == ""} {set pat Date}
  1260. #     set pat [prompt "Delete text until?" "Date"]
  1261.     if {![catch {search -s -f 1 -r 1 -i 0 -m 0 -- $pat $pos} data]} {
  1262.         deleteText $pos [lindex $data 0]
  1263.         return
  1264.     }
  1265.     beep
  1266.     message "no match."
  1267. }
  1268. ascii  0x8   <c>  deleteTill 
  1269. #===============================================================================
  1270.  
  1271. proc helperApps {} {
  1272.     set sigs [info globals *Sig]
  1273.     regsub -all {Sig} $sigs {} sigs
  1274.     set sig [listpick -p "Change/inspect which helper?" [lsort $sigs]]
  1275.     set sig ${sig}Sig
  1276.     global $sig modifiedVars
  1277.     if {![info exists $sig] || ([set $sig] == "")} {
  1278.         set text "Currently unassigned.   Set?"
  1279.     } elseif {[catch {nameFromAppl '[set $sig]'} name]} {
  1280.         set text "App w/ sig '[set $sig]' doesn't seem to exist.   Change?"
  1281.     } else {
  1282.         set text "Current value is '$name'.   Change?"
  1283.     }
  1284.     if {[askyesno $text] == "yes"} {
  1285.         set path [getfile "Locate new helper:"]
  1286.         set nsig [getFileSig $path]
  1287.         set app [nameFromAppl $nsig]
  1288.         if {$app != $path} {
  1289.             alertnote "Appl sig '$nsig' is mapped to '$app', not '$path'. Remove the former, or rebuild your desktop."
  1290.             return
  1291.         }
  1292.         if {[askyesno "Are you sure you want to set $sig to '$nsig' (mapped to '$app')?"] == "yes"} {
  1293.             set $sig $nsig
  1294.             lappend modifiedVars $sig
  1295.         }
  1296.     }
  1297. }
  1298. #===============================================================================
  1299.  
  1300. proc dumpNamedMacro {} {
  1301.     global macroArr
  1302.     set name [listpick -p "Macro name?" [array names macroArr]]
  1303.     regsub -all ";\r" $macroArr($name) "\r" text
  1304.     insertText $text
  1305. }
  1306.  
  1307.  
  1308. proc nameLastMacro {} {
  1309.     global macroArr modifiedArrVars
  1310.     set name [prompt "Macro name?" ""]
  1311.     regsub macroName [keyboardMacro] $name macro
  1312.     regsub -all "\r" $macro ";\r" macro
  1313.     eval $macro
  1314.     addMenuItem KbdMacros $name
  1315.     set macroArr($name) $macro
  1316.     lappend modifiedArrVars macroArr
  1317.     rebuildMacroMenu
  1318. }
  1319.  
  1320. proc deleteNamedMacro {} {
  1321.     global macroArr modifiedArrVars
  1322.     
  1323.     set which [listpick -p "Delete which macro?" [lsort [array names macroArr]]]
  1324.     unset macroArr($which)
  1325.     lappend modifiedArrVars macroArr
  1326.     rebuildMacroMenu
  1327. }
  1328.  
  1329. proc rebuildMacroMenu {} {
  1330.     global macroArr
  1331.     
  1332.     set l {}
  1333.     foreach f [lsort [array names macroArr]] {
  1334.         eval $macroArr($f)
  1335.         lappend l $f
  1336.     }
  1337.     eval menu -m -n macros [list $l]
  1338. }
  1339.